home *** CD-ROM | disk | FTP | other *** search
/ Linux Cubed Series 3: Developer Tools / Linux Cubed Series 3 - Developer Tools.iso / devel / lang / lisp / gcl-1.000 / gcl-1 / gcl-1.0 / cmpnew / cmpvs.lsp < prev    next >
Encoding:
Lisp/Scheme  |  1994-05-07  |  2.5 KB  |  94 lines
  1. ;;; CMPVS  Value stack manager.
  2. ;;;
  3. ;; Copyright (C) 1994 M. Hagiya, W. Schelter, T. Yuasa
  4.  
  5. ;; This file is part of GNU Common Lisp, herein referred to as GCL
  6. ;;
  7. ;; GCL is free software; you can redistribute it and/or modify it under
  8. ;;  the terms of the GNU LIBRARY GENERAL PUBLIC LICENSE as published by
  9. ;; the Free Software Foundation; either version 2, or (at your option)
  10. ;; any later version.
  11. ;; 
  12. ;; GCL is distributed in the hope that it will be useful, but WITHOUT
  13. ;; ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or
  14. ;; FITNESS FOR A PARTICULAR PURPOSE.  See the GNU Library General Public 
  15. ;; License for more details.
  16. ;; 
  17. ;; You should have received a copy of the GNU Library General Public License 
  18. ;; along with GCL; see the file COPYING.  If not, write to the Free Software
  19. ;; Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
  20.  
  21.  
  22. (in-package 'compiler)
  23.  
  24. (si:putprop 'vs 'set-vs 'set-loc)
  25. (si:putprop 'vs 'wt-vs 'wt-loc)
  26. (si:putprop 'vs* 'wt-vs* 'wt-loc)
  27. (si:putprop 'ccb-vs 'wt-ccb-vs 'wt-loc)
  28.  
  29. (defvar *vs* 0)
  30. (defvar *max-vs* 0)
  31. (defvar *clink* nil)
  32. (defvar *ccb-vs* 0)
  33. (defvar *initial-ccb-vs*)
  34. (defvar *level* 0)
  35.  
  36. ;;; *vs* holds the offset of the current vs-top.
  37. ;;; *max-vs* holds the maximum offset so far.
  38. ;;; *clink* holds NIL or the vs-address of the last ccb object.
  39. ;;; *ccb-vs* holds the top of the level 0 vs.
  40. ;;; *initial-ccb-vs* holds the value of *ccb-vs* when Pass 2 began to process
  41. ;;; a local (possibly closure) function.
  42. ;;; *level* holds the current function level.  *level* is 0 for a top-level
  43. ;;; function.
  44.  
  45. (defun vs-push ()
  46.   (prog1 (cons *level* *vs*)
  47.          (incf *vs*)
  48.          (setq *max-vs* (max *vs* *max-vs*))))
  49.  
  50. (defun set-vs (loc vs)
  51.   (unless (and (consp loc)
  52.                (eq (car loc) 'vs)
  53.                (equal (cadr loc) vs))
  54.           (wt-nl)
  55.           (wt-vs vs)
  56.           (wt "= " loc ";")))
  57.  
  58. (defun wt-vs (vs)
  59.   (cond ((eq (car vs) 'cvar)
  60.      (wt "V" (second vs)))
  61.     ((eq (car vs) 'cs)
  62.      (wt "Vcs[" (cdr vs) "]"))
  63.     (t
  64.      (if (= (car vs) *level*)
  65.          (wt "base[" (cdr vs) "]")
  66.        (wt "base" (car vs) "[" (cdr vs) "]")))))
  67.  
  68. (defun wt-vs* (vs)
  69.   (wt "(" )(wt-vs vs) (wt "->c.c_car)"))
  70.  
  71. (defun wt-ccb-vs (ccb-vs)
  72.   (wt "(base0[" (- *initial-ccb-vs* ccb-vs) "]->c.c_car)"))
  73.  
  74. (defun clink (vs) (setq *clink* vs))
  75.  
  76. (defun wt-clink (&optional (clink *clink*))
  77.   (if (null clink) (wt "Cnil") (wt-vs clink)))
  78.  
  79. (defun ccb-vs-push () (incf *ccb-vs*))
  80.  
  81.  
  82. (defun cvs-push ()
  83.   (prog1 (cons 'cs *cs*)
  84.     (incf *cs*)
  85.     ))
  86.  
  87.  
  88. (defun wt-list (l)
  89.   (do ((v l (cdr v)))
  90.       ((null v))
  91.       (wt (car v))
  92.       (or (null (cdr v)) (wt ","))))
  93.  
  94.